home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TURB_VIS / TVDMX / TVDMXREP.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-20  |  23KB  |  916 lines
  1.  
  2. {■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■}
  3. {                            }
  4. {    tvDMXREP  --tvDMX Data Reporting Objects    }
  5. {    tvDMX      --data editing project        }
  6. {                            }
  7. {    Copyright (c) 1992,94    Randolph Beck        }
  8. {                P.O. Box  56-0487    }
  9. {                Orlando, FL 32856    }
  10. {                CIS:  72361,753        }
  11. {                            }
  12. {■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■}
  13.  
  14. Unit tvDMXREP;
  15.  
  16. {$V-,X+,B-,R-,I- }
  17.  
  18. interface
  19.  
  20. uses
  21.     Dos, Objects, Drivers, Memory, Views, Dialogs, Menus, App, MsgBox,
  22.     RSet, DmxGizma, tvGizma, tvDMX, StdDMX;
  23.  
  24. const
  25.     NewLineStr    :  string[7] =    ^M^J;
  26.     NewPageStr    :  string[7] =    ^L;
  27.  
  28.     { Output Options }
  29.     repExtChars    =   1;    { Allow extended characters }
  30.     repLineNums    =   2;    { Display record/line numbers }
  31.     repCrLf    =   4;    { Line feed on carriage return }
  32.     repPgFeed    =   8;    { Manual page feed }
  33.  
  34.     { stand-ins for printing extended characters }
  35.     prnRadioBtn    : char    = '*';    { DMX RadioButton ON indicator }
  36.     prnCheckBox    : char    = 'X';    { DMX CheckBox ON indicator }
  37.     prnOVERFLOW    : char    = '*';    { TRUE indicator }
  38.     prnTRUE    : char    = '*';    { TRUE indicator }
  39.     prnFALSE    : char    = ' ';    { FALSE indicator }
  40.     prnBlock    : char    = ':';    { Block character }
  41.     prnUnprintable:char    = '.';    { out of printable range }
  42.  
  43.  
  44. type
  45.     PDmxReport    = ^TDmxReport;
  46.     TDmxReport    =  OBJECT(TObject)
  47.     Owner        : PView;
  48.     DMX        : PDmxScroller;
  49.     Delimiter    : char;
  50.     LineNums    : boolean;
  51.     CurPos        : integer;
  52.     LeftMargin    : integer;
  53.     RightMargin    : integer;
  54.     PageWidth    : integer;
  55.     PageSize    : integer;
  56.     CurrentPage    : integer;
  57.     CurrentLine    : integer;
  58.     CurrentRecord    : integer;
  59.     LastRecord    : integer;
  60.     MarginHit    : boolean;
  61.     ErrorInfo    : word;
  62.       constructor Init(aDMX : PDmxScroller;  ADelimiter : char;
  63.             ALineNums : boolean;  APageSize,APageWidth : integer);
  64.       procedure NewLine;
  65.       procedure PrintCtrl(St : string);
  66.       procedure DoPrint(var Buf;  Count : word);
  67.       procedure GotoPos(Pos : integer);
  68.       procedure Print(var Buf;    Count : word);    VIRTUAL;
  69.       procedure SetupPage;  VIRTUAL;
  70.       procedure EndPage;  VIRTUAL;
  71.       procedure SetupDMX;  VIRTUAL;
  72.       procedure EndDMX;  VIRTUAL;
  73.       procedure SetupLine;  VIRTUAL;
  74.       procedure EndLine;  VIRTUAL;
  75.       function    RecNumStr(RecNum : integer) : string;  VIRTUAL;
  76.       procedure PrintStr(St : string);
  77.       procedure PrintLabels;  VIRTUAL;
  78.       procedure PrintLn(St : string);
  79.       procedure PrintRec;
  80.       procedure PrintRows;
  81.       procedure Run;  VIRTUAL;
  82.     end;
  83.  
  84.  
  85.     PDmxReportFile  = ^TDmxReportFile;
  86.     TDmxReportFile  =  OBJECT(TDmxReport)
  87.     ReportText    : Text;
  88.       constructor Init(aDMX : PDmxScroller;  ADelimiter : char;
  89.             ALineNums : boolean;  APageSize,APageWidth : integer;
  90.             AFilename : FNameStr);
  91.       destructor  Done;  VIRTUAL;
  92.       procedure Print(var Buf;    Count : word);    VIRTUAL;
  93.     end;
  94.  
  95.  
  96.     PDmxReportStream  = ^TDmxReportStream;
  97.     TDmxReportStream  =  OBJECT(TDmxReport)
  98.     Stream        : PStream;
  99.       constructor Init(aDMX : PDmxScroller;  ADelimiter : char;
  100.             ALineNums : boolean;  APageSize,APageWidth : integer;
  101.             AStream : PStream);
  102.       procedure Print(var Buf;    Count : word);    VIRTUAL;
  103.     end;
  104.  
  105.  
  106.     TPrnOpt    = RECORD  { dialog box's data for printer-options }
  107.     Dest    : word;
  108.     FName    : string[23];
  109.     Options    : word;
  110.     Len,Wid    : word;
  111.     end;
  112.  
  113.  
  114.     _TAppPrn    =  OBJECT(TAppA)
  115.     end;
  116.  
  117.     TAppPrn    =  OBJECT(_TAppPrn)
  118.       procedure HandleEvent(var Event : TEvent);  VIRTUAL;
  119.       function    StdPrnMenuItems(AHelpCtx : word;  ANext : PMenuItem): PMenuItem;
  120.       procedure ReadConfigData(var S: TStream);  VIRTUAL;
  121.       procedure WriteConfigData(var S: TStream);  VIRTUAL;
  122.     end;
  123.  
  124.  
  125. var   PrnOpt    :  TPrnOpt;
  126.  
  127.   procedure DmxReportBoxRect(var R :TRect;  ATitle :TTitleStr; Msg :string; Report :PDmxReport);
  128.   procedure DmxReportBox(ATitle :TTitleStr; Msg :string; Report :PDmxReport);
  129.  
  130.   procedure PrnCurrentDMX;
  131.   procedure PrnPageStart(var Event : TEvent);
  132.   procedure PrnPageEnd(var Event : TEvent);
  133.   function  PrnSetOptions(AHelpCtx,AOKCtx,ACancelCtx : word) : word;
  134.  
  135.  
  136. implementation
  137.  
  138.   { ══ TDmxReport ════════════════════════════════════════════════════════ }
  139.  
  140.  
  141. constructor TDmxReport.Init(aDMX : PDmxScroller;  ADelimiter : char;
  142.         ALineNums : boolean;  APageSize,APageWidth : integer);
  143. begin
  144.   TObject.Init;
  145.   DMX        := aDMX;
  146.   Delimiter    := ADelimiter;
  147.   LineNums    := ALineNums;
  148.   PageSize    := APageSize;
  149.   PageWidth    := APageWidth;
  150.   If (DMX <> nil) and (DMX^.RecordSize > 0) then LastRecord := DMX^.RecordLimit;
  151. end;
  152.  
  153.  
  154. procedure TDmxReport.NewLine;
  155. begin
  156.   PrintCtrl(NewLineStr)
  157. end;
  158.  
  159.  
  160. procedure TDmxReport.PrintCtrl(St : string);
  161. var  i,j,x : integer;
  162.     procedure IncPos;
  163.     begin
  164.       inc(j);
  165.       If (j <= LeftMargin) or (j >= RightMargin) then
  166.     begin
  167.     Delete(St,i,1);
  168.     Dec(i);
  169.     end;
  170.     end;
  171.     procedure DecPos;
  172.     begin
  173.       dec(j);
  174.       If (j >= LeftMargin) or (j <= RightMargin) then
  175.     begin
  176.     Delete(St,i,1);
  177.     Dec(i);
  178.     end;
  179.     end;
  180. begin
  181.   If CtrlBreakHit then Exit;
  182.   j := CurPos;
  183.   If (length(St) > 0) then
  184.     begin
  185.     i := 1;
  186.     While (i <= length(St)) do
  187.       begin
  188.       Case St[i] of
  189.     ^H :  DecPos;
  190.     ^I :
  191.       begin
  192.       x := j;
  193.       Repeat inc(x) until (x mod 8 = 0);
  194.       If (j < LeftMargin) or (x > RightMargin) then
  195.         begin
  196.         Delete(St,i,1);
  197.         Dec(i);
  198.         Repeat
  199.           inc(j);
  200.           If (j > LeftMargin) and (j < RightMargin) then
  201.         begin
  202.         inc(i);
  203.         Insert(' ',St,i);
  204.         end;
  205.         Until (j mod 8 = 0);
  206.         end
  207.        else
  208.         j := x;
  209.       end;
  210.     ^J :
  211.       begin
  212.       inc(CurrentLine);
  213.       end;
  214.     ^L :
  215.       begin
  216.       inc(CurrentPage);
  217.       CurrentLine := 0;
  218.       j := 0;
  219.       end;
  220.     ^M :
  221.       begin
  222.       j := 0;
  223.       If (NewLineStr = ^M) then inc(CurrentLine);
  224.       end;
  225.        else  IncPos;
  226.     end;
  227.       inc(i);
  228.       end;
  229.     If (length(St) > 0) then Print(St[1], length(St));
  230.     CurPos := j;
  231.     end;
  232.   If (Application <> nil) then Application^.Idle;
  233. end;
  234.  
  235.  
  236. procedure TDmxReport.DoPrint(var Buf;  Count : word);
  237. var  i,j : integer;
  238.      x     : integer;
  239.      P     : PCharArray;
  240.      L     : longint;
  241. begin
  242.   If (Count = 0) or CtrlBreakHit then Exit;
  243.   P := @Buf;
  244.   L := Count;
  245.   x := CurPos + Count;
  246.   While (CurPos < LeftMargin) and (L > 0) do
  247.     begin
  248.     inc(ptrrec(P).ofs);
  249.     dec(L);
  250.     inc(CurPos);
  251.     end;
  252.   i := x;
  253.   While (i > RightMargin) and (L > 0) do
  254.     begin
  255.     dec(L);
  256.     dec(i);
  257.     MarginHit := TRUE;
  258.     end;
  259.   If (L > 0) then Print(P^, L);
  260.   CurPos := x;
  261. end;
  262.  
  263.  
  264. procedure TDmxReport.GotoPos(Pos : integer);
  265. begin
  266.   While (CurPos < Pos) do PrintCtrl(' ');
  267.   While (CurPos > Pos) do PrintCtrl(^H);
  268. end;
  269.  
  270.  
  271. procedure TDmxReport.Print(var Buf;  Count : word);
  272. begin
  273.   Abstract
  274. end;
  275.  
  276.  
  277. procedure TDmxReport.SetupPage;
  278. begin
  279. end;
  280.  
  281.  
  282. procedure TDmxReport.EndPage;
  283. begin
  284.   PrintCtrl(NewPageStr);
  285. end;
  286.  
  287.  
  288. procedure TDmxReport.SetupDMX;
  289. var  i : integer;
  290.      S : string;
  291. begin
  292.   S := RecNumStr(1) + '══';
  293.   If (Delimiter = #0) or (Delimiter >= #127) then S[1] := '═' else S[1] := '-';
  294.   If LineNums and (length(S) > 2) then
  295.     begin
  296.     FillChar(S[1], length(S), S[1]);
  297.     PrintStr(S);
  298.     end;
  299.   If (DMX^.Limit.X > 0) then For i := 1 to DMX^.Limit.X do PrintStr(S[1]);
  300.   NewLine;
  301. end;
  302.  
  303.  
  304. procedure TDmxReport.EndDMX;
  305. begin
  306.   SetupDMX;  { print the same divider line }
  307. end;
  308.  
  309.  
  310. procedure TDmxReport.SetupLine;
  311. begin
  312. end;
  313.  
  314.  
  315. procedure TDmxReport.EndLine;
  316. begin
  317.   NewLine
  318. end;
  319.  
  320.  
  321. function  TDmxReport.RecNumStr(RecNum : integer) : string;
  322. begin
  323.   RecNumStr := DMX^.RecNumStr(RecNum)
  324. end;
  325.  
  326.  
  327. procedure TDmxReport.PrintStr(St : string);
  328. begin
  329.   If (length(St) > 0) then DoPrint(St[1], length(St));
  330. end;
  331.  
  332.  
  333. procedure TDmxReport.PrintLabels;
  334. begin
  335.   If (DMX^.Labels <> nil) then With PDmxLabels(DMX^.Labels)^ do
  336.     begin
  337.     DoPrint(Data^, Len);
  338.     end;
  339. end;
  340.  
  341.  
  342. procedure TDmxReport.PrintLn(St : string);
  343. begin
  344.   PrintStr(St);
  345.   NewLine;
  346. end;
  347.  
  348.  
  349. procedure TDmxReport.PrintRec;
  350. var  i        : integer;
  351.      Color    : word;
  352.      A        : string;
  353.      fieldrec    : pDMXfieldrec;
  354.      DataRec    : pointer;
  355. begin
  356.   Color    := 0;
  357.   If (CurrentRecord < 0) or (CurrentRecord >= LastRecord) then
  358.     DataRec := nil
  359.    else
  360.     DataRec := DMX^.DataAt(CurrentRecord);
  361.   fieldrec := DMX^.DMXfield1;
  362.   While (fieldrec <> nil) do
  363.     begin
  364.     With fieldrec^ do
  365.       begin
  366.       If (access and accHidden = 0) then
  367.     begin
  368.     If access and accDelimiter <> 0 then
  369.       begin
  370.       If (typecode >= #127) and (Delimiter <> #0) then
  371.         A := Delimiter else A := typecode;
  372.       end
  373.      else
  374.       begin
  375.       If (DataRec = nil) then
  376.         begin
  377.         A[0] := char(fieldrec^.shownwid);
  378.         fillchar(A[1], length(A), ' ');
  379.         end
  380.        else
  381.         begin
  382.         A    := FieldString(fieldrec,[], DataRec^);
  383.         DMX^.FieldText(A, Color, fieldrec, DataRec^);
  384.         A[0] := char(fieldrec^.shownwid);
  385.         end;
  386.       For i := 1 to length(A) do
  387.         If (A[i] <= #31) or ((Delimiter <> #0) and (A[i] >= #127)) then
  388.           begin
  389.           If (A[i] = showRadioBtn)  then A[i] := prnRadioBtn
  390.           else
  391.           If (A[i] = showCheckBox)  then A[i] := prnCheckBox
  392.           else
  393.           If (A[i] = showTRUE)    then A[i] := prnTRUE
  394.           else
  395.           If (A[i] = showFALSE)    then A[i] := prnFALSE
  396.           else
  397.           If (A[i] = showOVERFLOW)    then A[i] := prnOVERFLOW
  398.           else
  399.         begin
  400.         Case A[i] of
  401.           '═':            A[i] := '=';
  402.           '─':            A[i] := '-';
  403.           '░','▒','▓','█':    A[i] := prnBlock;
  404.           #0:            A[i] := ' ';
  405.           #1..#31, #127..#255:    A[i] := prnUnprintable;
  406.           end;
  407.         end;
  408.           end;
  409.       end;
  410.     PrintStr(A);
  411.     end;
  412.       end;
  413.     fieldrec := fieldrec^.Next;
  414.     end;
  415. end;
  416.  
  417.  
  418. procedure TDmxReport.PrintRows;
  419. var  Recs : integer;
  420.      Line : string;
  421.      F      : pDMXfieldrec;
  422. begin
  423.   SetupDMX;
  424.   Recs := CurrentRecord + PageSize;
  425.   F := DMX^.DMXfield1;
  426.   While (CurrentRecord < Recs) and (not CtrlBreakHit) do
  427.     begin
  428.     SetupLine;
  429.     If LineNums then
  430.       begin
  431.       Line := RecNumStr(CurrentRecord) + '│ ';
  432.       If (length(Line) > 2) then
  433.     begin
  434.     If (Delimiter <> #0) then Line[length(Line) - 1] := Delimiter;
  435.     PrintStr(Line);
  436.     end;
  437.       end;
  438.     PrintRec;
  439.     EndLine;
  440.     Inc(CurrentRecord);
  441.     end;
  442.   If not CtrlBreakHit then EndDMX;
  443. end;
  444.  
  445.  
  446. procedure TDmxReport.Run;
  447. var  i,n : integer;
  448.      b     : boolean;
  449.      S     : string;
  450.      P     : PView;
  451. begin
  452.   If (DMX^.Owner <> nil) then P := DMX^.Owner else P := DMX;
  453.   CtrlBreakHit    := FALSE;
  454.   While (CurrentRecord < LastRecord) and (not CtrlBreakHit) do
  455.     begin
  456.     LeftMargin    := 0;
  457.     RightMargin := PageWidth;
  458.     n := CurrentRecord;
  459.     Repeat
  460.       MarginHit := FALSE;
  461.       CurPos    := 0;
  462.       If (Application <> nil) then
  463.     Message(Application, evCommand, cmPRN_NewPage, @Self);
  464.       If (P^.State and sfActive = 0) then
  465.     Message(P, evCommand, cmPRN_NewPage, @Self);
  466.       SetupPage;
  467.       If (DMX^.Labels <> nil) then
  468.     begin
  469.     S := RecNumStr(1) + '  ';
  470.     If LineNums and (length(S) > 2) then
  471.       begin
  472.       FillChar(S[1], length(S), ' ');
  473.       If (Delimiter <> #0) then S[length(S) - 1] := Delimiter;
  474.       PrintStr(S);
  475.       end;
  476.     PrintLabels;
  477.     NewLine;
  478.     end;
  479.       PrintRows;
  480.       If not CtrlBreakHit then
  481.     begin
  482.     If (DMX^.State and sfActive = 0) then
  483.       b := (Message(DMX, evCommand, cmPRN_EndPage, @Self) = nil)
  484.      else
  485.       b := TRUE;
  486.     If b and (Application <> nil) then
  487.       Message(Application, evCommand, cmPRN_EndPage, @Self);
  488.     If not CtrlBreakHit then EndPage;
  489.     end;
  490.       If MarginHit then
  491.     begin
  492.     Inc(RightMargin, PageWidth);
  493.     Inc(LeftMargin,  PageWidth);
  494.     Dec(CurrentPage);
  495.     CurrentRecord := n;
  496.     end;
  497.     Until CtrlBreakHit or not MarginHit;
  498.     end;
  499. end;
  500.  
  501.  
  502.   { ══ TDmxReportFile ════════════════════════════════════════════════════ }
  503.  
  504.  
  505. constructor TDmxReportFile.Init(aDMX : PDmxScroller;  ADelimiter : char;
  506.             ALineNums : boolean; APageSize,APageWidth : integer;
  507.             AFilename : FNameStr);
  508. begin
  509.   TDmxReport.Init(aDMX, ADelimiter, ALineNums, APageSize,APageWidth);
  510.   Assign(ReportText, AFilename);
  511.   Append(ReportText);
  512.   ErrorInfo := IOResult;
  513.   If (ErrorInfo <> 0) then
  514.     begin
  515.     ReWrite(ReportText);
  516.     ErrorInfo := IOResult;
  517.     end;
  518. end;
  519.  
  520.  
  521. destructor TDmxReportFile.Done;
  522. begin
  523.   Close(ReportText);
  524.   TDmxReport.Done;
  525. end;
  526.  
  527.  
  528. procedure TDmxReportFile.Print(var Buf;  Count : word);
  529. var  Reg : registers;
  530. begin
  531.   If (ErrorInfo = 0) and (Count > 0) then
  532.     begin
  533.     With Reg do
  534.       begin
  535.       DS := seg(Buf);
  536.       DX := ofs(Buf);
  537.       CX := Count;
  538.       BX := textrec(ReportText).Handle;
  539.       AX := $4000;
  540.       end;
  541.     MsDos(Reg);
  542.     If (Reg.Flags and FCarry <> 0) then ErrorInfo := Reg.AX;
  543.     end;
  544. end;
  545.  
  546.  
  547.   { ══ TDmxReportStream ══════════════════════════════════════════════════ }
  548.  
  549.  
  550. constructor TDmxReportStream.Init(aDMX : PDmxScroller;    ADelimiter : char;
  551.             ALineNums : boolean;  APageSize,APageWidth : integer;
  552.             AStream : PStream);
  553. begin
  554.   TDmxReport.Init(aDMX, ADelimiter, ALineNums, APageSize,APageWidth);
  555.   Stream := AStream;
  556. end;
  557.  
  558.  
  559. procedure TDmxReportStream.Print(var Buf;  Count : word);
  560. begin
  561.   Stream^.Write(Buf, Count);
  562.   If (Stream^.ErrorInfo <> stOK) then ErrorInfo := Stream^.ErrorInfo;
  563. end;
  564.  
  565.  
  566.   { ══════════════════════════════════════════════════════════════════════ }
  567.  
  568. type
  569.     PBlueText    = ^TBlueText;
  570.     TBlueText    =  OBJECT(TStaticText)
  571.       function    GetPalette : PPalette;    VIRTUAL;
  572.     end;
  573.  
  574.  
  575. function  TBlueText.GetPalette : PPalette;
  576. const CBlueText : string[1] = #19;
  577. begin
  578.   GetPalette := @CBlueText;
  579. end;
  580.  
  581.  
  582. procedure DmxReportBoxRect(var R : TRect;  ATitle : TTitleStr;
  583.                Msg : string; Report : PDmxReport);
  584. var  Rect    : TRect;
  585.      View    : PStaticText;
  586.      ECode    : longint;
  587.      Watch    : PDialog;
  588. begin
  589.   If (Report <> nil) and (Report^.DMX <> nil) and
  590.      (Report^.DMX^.RecordLimit > 0) then
  591.     begin
  592.     Watch := New(PDialog, Init(R, ATitle));
  593.     If (longint(R.A) = 0) then Watch^.Options := Watch^.Options or ofCentered;
  594.     Watch^.Flags := 0;
  595.  
  596.     Rect.Assign(3, 2, Watch^.Size.X - 2, Watch^.Size.Y - 3);
  597.     Watch^.Insert(New(PStaticText, Init(Rect, Msg)));
  598.  
  599.     Rect.Assign(1, Watch^.Size.Y - 2, Watch^.Size.X - 1, Watch^.Size.Y - 1);
  600.     Watch^.Insert(New(PBlueText, Init(Rect, ^C'Press Ctrl-Break to cancel')));
  601.  
  602.     DeskTop^.Insert(Watch);
  603.     Report^.Owner := Watch;
  604.     Report^.Run;
  605.     DeskTop^.Delete(Watch);
  606.     Report^.Owner := nil;
  607.     Dispose(Watch, Done);
  608.     If (Report^.ErrorInfo <> 0) then
  609.       begin
  610.       ECode := Report^.ErrorInfo;
  611.       MessageBox('Device error: %d.', @ECode, mfError or mfOKButton);
  612.       end;
  613.     CtrlBreakHit := FALSE;
  614.     end
  615.    else
  616.     MessageBox('No data for reporting.', nil, mfError or mfOKButton);
  617.   If (Report <> nil) then Dispose(Report, Done);
  618. end;
  619.  
  620.  
  621. procedure DmxReportBox(ATitle :TTitleStr; Msg :string; Report :PDmxReport);
  622. var  Rect    : TRect;
  623. begin
  624.   Rect.Assign(0,0, 50,9);
  625.   DmxReportBoxRect(Rect, ATitle, Msg, Report);
  626. end;
  627.  
  628.  
  629.   { ══════════════════════════════════════════════════════════════════════ }
  630.  
  631.  
  632. procedure PrnCurrentDMX;
  633. var  ToName    : FNameStr;
  634.      C        : char;
  635.      E        : TEvent;
  636. begin
  637.   If (PrnOpt.Dest = 1) then ToName := PrnOpt.FName else ToName := 'PRN';
  638.   If (PrnOpt.Options and repExtChars = 0) then C := '|' else C := #0;
  639.   If (PrnOpt.Options and repCrLf = 0) then NewLineStr := ^M else NewLineStr := ^M^J;
  640.   If (ToName = '') then
  641.     MessageBox('No output filename given.', nil, mfError + mfOKButton)
  642.   else
  643.   If (PrnOpt.Len < 1) or (PrnOpt.Wid < 10) then
  644.     MessageBox('Page width or length is too short.', nil, mfError + mfOKButton)
  645.    else
  646.     begin
  647.     DmxReportBox('Printing',  'Processing output to...'^M^M^C + ToName,
  648.     New(PDmxReportFile, Init(Message(DeskTop, evCommand, cmDMX_RollCall, Application),
  649.          C,(PrnOpt.Options and repLineNums = repLineNums), PrnOpt.Len, PrnOpt.Wid, ToName))
  650.       );
  651.     Exit;
  652.     end;
  653.   If (Application <> nil) then
  654.     begin
  655.     E.What    := evCommand;
  656.     E.Command := cmPRN_SetOptions;
  657.     E.InfoPtr := Application;
  658.     Application^.PutEvent(E);
  659.     end;
  660. end;
  661.  
  662.  
  663. procedure PrnPageStart(var Event : TEvent);
  664. begin
  665.   With PDmxReport(Event.InfoPtr)^ do
  666.     If (DMX^.Owner <> nil) and (PWindow(DMX^.Owner)^.Title <> nil) then
  667.       PrintLn(PWindow(DMX^.Owner)^.Title^);
  668. end;
  669.  
  670.  
  671. procedure PrnPageEnd(var Event : TEvent);
  672. var  S : string[80];
  673. begin
  674.   With PDmxReport(Event.InfoPtr)^ do
  675.     begin
  676.     If (PageSize <= 0) or (LastRecord <= 0) then Exit;
  677.     FormatStr(S, 'Page %d of %d',
  678.     dparam(succ(CurrentPage),
  679.     dparam(succ(pred(LastRecord) div PageSize),
  680.     nil))^);
  681.     PrintLn(S);
  682.     end;
  683. end;
  684.  
  685.  
  686. function  PrnSetOptions(AHelpCtx,AOKCtx,ACancelCtx : word) : word;
  687. {  AHelpCtx+0 = 'Destination: Printer'
  688.    AHelpCtx+1 = 'Destination: File'
  689.    AHelpCtx+2 = 'Destination: (Filename)'
  690.    AHelpCtx+3 = 'Options: Allow extended characters'
  691.    AHelpCtx+4 = 'Options: Display record numbers'
  692.    AHelpCtx+5 = 'Options: Line feed on carriage return'
  693.    AHelpCtx+6 = 'Options: Manual page feed'
  694.    AHelpCtx+7 = 'Page Length'
  695.    AHelpCtx+8 = 'Page Width'
  696.  }
  697. var  i    : integer;
  698.      R    : TRect;
  699.      D    : PDialog;
  700.  
  701.     function  InsertRadioButtons : PView;
  702.     var  R   : TRect;
  703.      P   : PView;
  704.     begin
  705.       R.Assign(3, 3, 38, 5);
  706.       P := New(PRadioButtons, Init(R,
  707.         NewSItem('~P~rinter',
  708.         NewSItem('~F~ile:',
  709.         nil))
  710.          ));
  711.       P^.HelpCtx := AHelpCtx;
  712.       D^.Insert(P);
  713.       InsertRadioButtons := P;
  714.     end;
  715.  
  716.     function  InsertCheckBoxes : PView;
  717.     var  R   : TRect;
  718.      P   : PView;
  719.     begin
  720.       R.Assign(3, 7, 38, 11);
  721.       P := New(PCheckBoxes, Init(R,
  722.         NewSItem('~A~llow extended characters',
  723.         NewSItem('~D~isplay record/line numbers',
  724.         NewSItem('L~i~ne feed on carriage return',
  725.         NewSItem('~M~anual page feed',
  726.         nil))))
  727.          ));
  728.       P^.HelpCtx := AHelpCtx + 3;
  729.       D^.Insert(P);
  730.       InsertCheckBoxes := P;
  731.     end;
  732.  
  733. begin
  734.   PrnSetOptions := cmCancel;
  735.   If (Application = nil) then Exit;
  736.   R.Assign(0,0, 40,18);
  737.   D := New(PDialog, Init(R, 'Print Settings'));
  738.   With D^ do
  739.     begin
  740.     Options := Options or ofCentered;
  741.  
  742.     R.Assign(4, 2, 16, 3);
  743.     Insert(New(PLabel, Init(R, '~D~estination', InsertRadioButtons)));
  744.  
  745.     InsertField(D, 14,4, FALSE, '', ' SSSSSSSSSSSSSSSSSSSSSSS')^.HelpCtx := AHelpCtx + 2;
  746.  
  747.     R.Assign(4, 6, 16, 7);
  748.     Insert(New(PLabel, Init(R, '~O~ptions', InsertCheckBoxes)));
  749.  
  750.     InsertField(D, 4,12, FALSE, 'Page ~L~ength: ', 'WWWW ')^.HelpCtx := AHelpCtx + 7;
  751.     InsertField(D, 4,13, FALSE, 'Page ~W~idth:  ', 'WWWW ')^.HelpCtx := AHelpCtx + 8;
  752.  
  753.     R.Assign(7, 15, 17, 17);
  754.     Insert(New(PButton, Init(R, 'O~K~', cmOK, bfDefault)));
  755.     Current^.HelpCtx := AOKCtx;
  756.  
  757.     R.Assign(21, 15, 33, 17);
  758.     Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));
  759.     Current^.HelpCtx := ACancelCtx;
  760.  
  761.     SelectNext(FALSE);
  762.     end;
  763.  
  764.   If (Application^.ValidView(D) <> nil) then
  765.     begin
  766.     D^.SetData(PrnOpt);
  767.     If (DeskTop^.ExecView(D) = cmOK) then
  768.       begin
  769.       D^.GetData(PrnOpt);
  770.       While (PrnOpt.FName[length(PrnOpt.FName)] = ' ') do Dec(PrnOpt.FName[0]);
  771.       While (PrnOpt.FName[1] = ' ') and (length(PrnOpt.FName) > 0) do
  772.     System.Delete(PrnOpt.FName, 1,1);
  773.       PrnSetOptions := cmOK;
  774.       end;
  775.     Dispose(D, Done);
  776.     end;
  777. end;
  778.  
  779.  
  780.   { ══ TAppPrn ═══════════════════════════════════════════════════════════ }
  781.  
  782.  
  783. procedure TAppPrn.HandleEvent(var Event : TEvent);
  784. var  SysCommand : boolean;
  785.      E        : TEvent;
  786.  
  787.     procedure WaitForNewPage;
  788.     const Msg    = 'Insert a sheet for printing.';
  789.     var   R    : TRect;
  790.       D    : PDialog;
  791.     begin
  792.       If not CtrlBreakHit and ((PrnOpt.Options and repPgFeed <> 0) and (PrnOpt.Dest <> 1)) then
  793.     begin
  794.     If (DeskTop^.Current = nil) then
  795.       begin
  796.       R.Assign(0, 0, 41, 13);
  797.       R.Move((DeskTop^.Size.X - (R.B.X - R.A.X)),(DeskTop^.Size.Y - (R.B.Y - R.A.Y)));
  798.       end
  799.      else
  800.       DeskTop^.Current^.GetBounds(R);
  801.     D := New(PDialog, Init(R, 'New Page'));
  802.     With D^ do
  803.       begin
  804.       GetExtent(R);
  805.       R.Grow(-3,-2);
  806.       Insert(New(PStaticText, Init(R, Msg)));
  807.       R.Assign((Size.X shr 1) + 1, Size.Y - 3,(Size.X shr 1) + 11, Size.Y - 1);
  808.       Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));
  809.       R.Assign((Size.X shr 1) - 11, Size.Y - 3,(Size.X shr 1) - 1, Size.Y - 1);
  810.       Insert(New(PButton, Init(R, 'O~K~', cmOK, bfDefault)));
  811.       end;
  812.     CtrlBreakHit := (DeskTop^.ExecView(D) = cmCancel);
  813.     Dispose(D, Done);
  814.     end;
  815.     end;
  816.  
  817.     procedure PrintChar(S : string);
  818.     var  Prn : Text;
  819.      Err : word;
  820.      St  : string;
  821.     begin
  822.       Assign(Prn,'PRN');
  823.       ReWrite(Prn);
  824.       Err := IOResult;
  825.       If (Err = 0) then
  826.     begin
  827.     St := S;
  828.     If (St = ^M) then
  829.       If (PrnOpt.Options and 4 = 0) then St := ^M else St := ^M^J;
  830.     write(Prn, St);
  831.     Err := IOResult;
  832.     Close(Prn);
  833.     end;
  834.     end;
  835.  
  836.     procedure ResetPrinter;
  837.     var  Reg: Registers;
  838.     begin
  839.      {$IFDEF DPMI }
  840.       Reg.AX := 1;
  841.       Reg.DX := 0;
  842.       Intr($17, Reg);
  843.      {$ELSE }
  844.       asm
  845.     mov    ah,  1
  846.     xor    dx, dx
  847.     int    17h
  848.     end;
  849.      {$ENDIF }
  850.     end;
  851.  
  852. begin
  853.   If (Event.What = evCommand) and (Event.Command = cmPRN_NewPage) then
  854.     WaitForNewPage;
  855.   _TAppPrn.HandleEvent(Event);
  856.   If (Event.What = evCommand) then
  857.     begin
  858.     Case Event.Command of
  859.       cmPRN_LineFeed:    PrintChar(^M);
  860.       cmPRN_FormFeed:    PrintChar(^L);
  861.       cmPRN_Reset:    ResetPrinter;
  862.       end;
  863.    { Event is not cleared for these commands }
  864.     end;
  865. end;
  866.  
  867.  
  868. function  TAppPrn.StdPrnMenuItems(AHelpCtx : word;  ANext : PMenuItem): PMenuItem;
  869.     function  hc(N : word) : word;
  870.     begin
  871.       If (AHelpCtx = hcNoContext) then hc := hcNoContext else hc := AHelpCtx + N;
  872.     end;
  873. begin
  874.   StdPrnMenuItems :=
  875.     NewItem('~S~ettings...','', kbNoKey, cmPRN_SetOptions, AHelpCtx,
  876.     NewLine(
  877.     NewItem('~L~ine feed',    '',  kbNoKey, cmPRN_LineFeed, hc(1),
  878.     NewItem('~F~orm feed',    '',  kbNoKey, cmPRN_FormFeed, hc(2),
  879.     NewItem('~R~eset',    '',  kbNoKey, cmPRN_Reset,    hc(3),
  880.     ANext)))));
  881. end;
  882.  
  883.  
  884. procedure TAppPrn.ReadConfigData(var S: TStream);
  885. begin
  886.   inherited ReadConfigData(S);
  887.   S.Read(PrnOpt, sizeof(PrnOpt));
  888. end;
  889.  
  890.  
  891. procedure TAppPrn.WriteConfigData(var S: TStream);
  892. begin
  893.   inherited WriteConfigData(S);
  894.   S.Write(PrnOpt, sizeof(PrnOpt));
  895. end;
  896.  
  897.  
  898.   { ══════════════════════════════════════════════════════════════════════ }
  899.  
  900. var R : TRect;
  901.     D : DirStr;
  902.     N : NameStr;
  903.     X : ExtStr;
  904.  
  905. Begin
  906.   PrnOpt.Dest     := 1;
  907.   PrnOpt.Options := repLineNums or repCrLf;
  908.   PrnOpt.Len     := 55;
  909.   PrnOpt.Wid     := 78;
  910.   If (ParamStr(0) = '') then PrnOpt.FName := 'FILE.OUT' else
  911.     begin
  912.     FSplit(ParamStr(0), D,N,X);
  913.     PrnOpt.FName := N + '.OUT';
  914.     end;
  915. End.
  916.